home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / Mouse / PurePerl.pm < prev    next >
Encoding:
Perl POD Document  |  2010-07-26  |  21.3 KB  |  789 lines

  1. package Mouse::PurePerl;
  2.  
  3. require Mouse::Util;
  4.  
  5. package Mouse::Util;
  6.  
  7. use strict;
  8. use warnings;
  9.  
  10. use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl
  11.  
  12. use B ();
  13.  
  14.  
  15. # taken from Class/MOP.pm
  16. sub is_valid_class_name {
  17.     my $class = shift;
  18.  
  19.     return 0 if ref($class);
  20.     return 0 unless defined($class);
  21.  
  22.     return 1 if $class =~ /\A \w+ (?: :: \w+ )* \z/xms;
  23.  
  24.     return 0;
  25. }
  26.  
  27. sub is_class_loaded {
  28.     my $class = shift;
  29.  
  30.     return 0 if ref($class) || !defined($class) || !length($class);
  31.  
  32.     # walk the symbol table tree to avoid autovififying
  33.     # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::
  34.  
  35.     my $pack = \%::;
  36.     foreach my $part (split('::', $class)) {
  37.         $part .= '::';
  38.         return 0 if !exists $pack->{$part};
  39.  
  40.         my $entry = \$pack->{$part};
  41.         return 0 if ref($entry) ne 'GLOB';
  42.         $pack = *{$entry}{HASH};
  43.     }
  44.  
  45.     return 0 if !%{$pack};
  46.  
  47.     # check for $VERSION or @ISA
  48.     return 1 if exists $pack->{VERSION}
  49.              && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
  50.     return 1 if exists $pack->{ISA}
  51.              && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
  52.  
  53.     # check for any method
  54.     foreach my $name( keys %{$pack} ) {
  55.         my $entry = \$pack->{$name};
  56.         return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
  57.     }
  58.  
  59.     # fail
  60.     return 0;
  61. }
  62.  
  63.  
  64. # taken from Sub::Identify
  65. sub get_code_info {
  66.     my ($coderef) = @_;
  67.     ref($coderef) or return;
  68.  
  69.     my $cv = B::svref_2object($coderef);
  70.     $cv->isa('B::CV') or return;
  71.  
  72.     my $gv = $cv->GV;
  73.     $gv->isa('B::GV') or return;
  74.  
  75.     return ($gv->STASH->NAME, $gv->NAME);
  76. }
  77.  
  78. sub get_code_package{
  79.     my($coderef) = @_;
  80.  
  81.     my $cv = B::svref_2object($coderef);
  82.     $cv->isa('B::CV') or return '';
  83.  
  84.     my $gv = $cv->GV;
  85.     $gv->isa('B::GV') or return '';
  86.  
  87.     return $gv->STASH->NAME;
  88. }
  89.  
  90. sub get_code_ref{
  91.     my($package, $name) = @_;
  92.     no strict 'refs';
  93.     no warnings 'once';
  94.     use warnings FATAL => 'uninitialized';
  95.     return *{$package . '::' . $name}{CODE};
  96. }
  97.  
  98. sub generate_isa_predicate_for {
  99.     my($for_class, $name) = @_;
  100.  
  101.     my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) };
  102.  
  103.     if(defined $name){
  104.         Mouse::Util::install_subroutines(scalar caller, $name => $predicate);
  105.         return;
  106.     }
  107.  
  108.     return $predicate;
  109. }
  110.  
  111. sub generate_can_predicate_for {
  112.     my($methods_ref, $name) = @_;
  113.  
  114.     my @methods = @{$methods_ref};
  115.  
  116.     my $predicate = sub{
  117.         my($instance) = @_;
  118.         if(Scalar::Util::blessed($instance)){
  119.             foreach my $method(@methods){
  120.                 if(!$instance->can($method)){
  121.                     return 0;
  122.                 }
  123.             }
  124.             return 1;
  125.         }
  126.         return 0;
  127.     };
  128.  
  129.     if(defined $name){
  130.         Mouse::Util::install_subroutines(scalar caller, $name => $predicate);
  131.         return;
  132.     }
  133.  
  134.     return $predicate;
  135. }
  136.  
  137. package Mouse::Util::TypeConstraints;
  138.  
  139. use Scalar::Util qw(blessed looks_like_number openhandle);
  140.  
  141. sub Any        { 1 }
  142. sub Item       { 1 }
  143.  
  144. sub Bool       { $_[0] ? $_[0] eq '1' : 1 }
  145. sub Undef      { !defined($_[0]) }
  146. sub Defined    {  defined($_[0])  }
  147. sub Value      {  defined($_[0]) && !ref($_[0]) }
  148. sub Num        {  looks_like_number($_[0]) }
  149. sub Int        {
  150.     my($value) = @_;
  151.     looks_like_number($value) && $value =~ /\A [+-]? [0-9]+  \z/xms;
  152. }
  153. sub Str        {
  154.     my($value) = @_;
  155.     return defined($value) && ref(\$value) eq 'SCALAR';
  156. }
  157.  
  158. sub Ref        { ref($_[0]) }
  159. sub ScalarRef  {
  160.     my($value) = @_;
  161.     return ref($value) eq 'SCALAR'
  162. }
  163. sub ArrayRef   { ref($_[0]) eq 'ARRAY'  }
  164. sub HashRef    { ref($_[0]) eq 'HASH'   }
  165. sub CodeRef    { ref($_[0]) eq 'CODE'   }
  166. sub RegexpRef  { ref($_[0]) eq 'Regexp' }
  167. sub GlobRef    { ref($_[0]) eq 'GLOB'   }
  168.  
  169. sub FileHandle {
  170.     return openhandle($_[0])  || (blessed($_[0]) && $_[0]->isa("IO::Handle"))
  171. }
  172.  
  173. sub Object     { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
  174.  
  175. sub ClassName  { Mouse::Util::is_class_loaded($_[0]) }
  176. sub RoleName   { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') }
  177.  
  178. sub _parameterize_ArrayRef_for {
  179.     my($type_parameter) = @_;
  180.     my $check = $type_parameter->_compiled_type_constraint;
  181.  
  182.     return sub {
  183.         foreach my $value (@{$_}) {
  184.             return undef unless $check->($value);
  185.         }
  186.         return 1;
  187.     }
  188. }
  189.  
  190. sub _parameterize_HashRef_for {
  191.     my($type_parameter) = @_;
  192.     my $check = $type_parameter->_compiled_type_constraint;
  193.  
  194.     return sub {
  195.         foreach my $value(values %{$_}){
  196.             return undef unless $check->($value);
  197.         }
  198.         return 1;
  199.     };
  200. }
  201.  
  202. # 'Maybe' type accepts 'Any', so it requires parameters
  203. sub _parameterize_Maybe_for {
  204.     my($type_parameter) = @_;
  205.     my $check = $type_parameter->_compiled_type_constraint;
  206.  
  207.     return sub{
  208.         return !defined($_) || $check->($_);
  209.     };
  210. }
  211.  
  212. package Mouse::Meta::Module;
  213.  
  214. sub name          { $_[0]->{package} }
  215.  
  216. sub _method_map   { $_[0]->{methods} }
  217. sub _attribute_map{ $_[0]->{attributes} }
  218.  
  219. sub namespace{
  220.     my $name = $_[0]->{package};
  221.     no strict 'refs';
  222.     return \%{ $name . '::' };
  223. }
  224.  
  225. sub add_method {
  226.     my($self, $name, $code) = @_;
  227.  
  228.     if(!defined $name){
  229.         $self->throw_error('You must pass a defined name');
  230.     }
  231.     if(!defined $code){
  232.         $self->throw_error('You must pass a defined code');
  233.     }
  234.  
  235.     if(ref($code) ne 'CODE'){
  236.         $code = \&{$code}; # coerce
  237.     }
  238.  
  239.     $self->{methods}->{$name} = $code; # Moose stores meta object here.
  240.  
  241.     Mouse::Util::install_subroutines($self->name,
  242.         $name => $code,
  243.     );
  244.     return;
  245. }
  246.  
  247. package Mouse::Meta::Class;
  248.  
  249. use Mouse::Meta::Method::Constructor;
  250. use Mouse::Meta::Method::Destructor;
  251.  
  252. sub method_metaclass    { $_[0]->{method_metaclass}    || 'Mouse::Meta::Method'    }
  253. sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' }
  254.  
  255. sub constructor_class { $_[0]->{constructor_class} || 'Mouse::Meta::Method::Constructor' }
  256. sub destructor_class  { $_[0]->{destructor_class}  || 'Mouse::Meta::Method::Destructor'  }
  257.  
  258. sub is_anon_class{
  259.     return exists $_[0]->{anon_serial_id};
  260. }
  261.  
  262. sub roles { $_[0]->{roles} }
  263.  
  264. sub linearized_isa { @{ get_linear_isa($_[0]->{package}) } }
  265.  
  266. sub get_all_attributes {
  267.     my($self) = @_;
  268.     my %attrs = map { %{ $self->initialize($_)->{attributes} } } reverse $self->linearized_isa;
  269.     return values %attrs;
  270. }
  271.  
  272. sub new_object {
  273.     my $meta = shift;
  274.     my %args = (@_ == 1 ? %{$_[0]} : @_);
  275.  
  276.     my $object = bless {}, $meta->name;
  277.  
  278.     $meta->_initialize_object($object, \%args);
  279.     # BUILDALL
  280.     if( $object->can('BUILD') ) {
  281.         for my $class (reverse $meta->linearized_isa) {
  282.             my $build = Mouse::Util::get_code_ref($class, 'BUILD')
  283.                 || next;
  284.  
  285.             $object->$build(\%args);
  286.         }
  287.     }
  288.     return $object;
  289. }
  290.  
  291. sub clone_object {
  292.     my $class  = shift;
  293.     my $object = shift;
  294.     my $args   = $object->Mouse::Object::BUILDARGS(@_);
  295.  
  296.     (blessed($object) && $object->isa($class->name))
  297.         || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
  298.  
  299.     my $cloned = bless { %$object }, ref $object;
  300.     $class->_initialize_object($cloned, $args, 1);
  301.  
  302.     return $cloned;
  303. }
  304.  
  305. sub _initialize_object{
  306.     my($self, $object, $args, $is_cloning) = @_;
  307.  
  308.     my @triggers_queue;
  309.  
  310.     my $used = 0;
  311.  
  312.     foreach my $attribute ($self->get_all_attributes) {
  313.         my $init_arg = $attribute->init_arg;
  314.         my $slot     = $attribute->name;
  315.  
  316.         if (defined($init_arg) && exists($args->{$init_arg})) {
  317.             $object->{$slot} = $attribute->_coerce_and_verify($args->{$init_arg}, $object);
  318.  
  319.             weaken($object->{$slot})
  320.                 if ref($object->{$slot}) && $attribute->is_weak_ref;
  321.  
  322.             if ($attribute->has_trigger) {
  323.                 push @triggers_queue, [ $attribute->trigger, $object->{$slot} ];
  324.             }
  325.             $used++;
  326.         }
  327.         else { # no init arg
  328.             if ($attribute->has_default || $attribute->has_builder) {
  329.                 if (!$attribute->is_lazy && !exists $object->{$slot}) {
  330.                     my $default = $attribute->default;
  331.                     my $builder = $attribute->builder;
  332.                     my $value =   $builder                ? $object->$builder()
  333.                                 : ref($default) eq 'CODE' ? $object->$default()
  334.                                 :                           $default;
  335.  
  336.                     $object->{$slot} = $attribute->_coerce_and_verify($value, $object);
  337.  
  338.                     weaken($object->{$slot})
  339.                         if ref($object->{$slot}) && $attribute->is_weak_ref;
  340.                 }
  341.             }
  342.             elsif(!$is_cloning && $attribute->is_required) {
  343.                 $self->throw_error("Attribute (".$attribute->name.") is required");
  344.             }
  345.         }
  346.     }
  347.  
  348.     if($used < keys %{$args} && $self->strict_constructor) {
  349.         $self->_report_unknown_args([ $self->get_all_attributes ], $args);
  350.     }
  351.  
  352.     if(@triggers_queue){
  353.         foreach my $trigger_and_value(@triggers_queue){
  354.             my($trigger, $value) = @{$trigger_and_value};
  355.             $trigger->($object, $value);
  356.         }
  357.     }
  358.  
  359.     if($self->is_anon_class){
  360.         $object->{__METACLASS__} = $self;
  361.     }
  362.  
  363.     return;
  364. }
  365.  
  366. sub is_immutable {  $_[0]->{is_immutable} }
  367.  
  368. sub strict_constructor{
  369.     my $self = shift;
  370.     if(@_) {
  371.         $self->{strict_constructor} = shift;
  372.     }
  373.  
  374.     foreach my $class($self->linearized_isa) {
  375.         my $meta = Mouse::Util::get_metaclass_by_name($class)
  376.             or next;
  377.  
  378.         if(exists $meta->{strict_constructor}) {
  379.             return $meta->{strict_constructor};
  380.         }
  381.     }
  382.  
  383.     return 0; # false
  384. }
  385.  
  386. sub _report_unknown_args {
  387.     my($metaclass, $attrs, $args) = @_;
  388.  
  389.     my @unknowns;
  390.     my %init_args;
  391.     foreach my $attr(@{$attrs}){
  392.         my $init_arg = $attr->init_arg;
  393.         if(defined $init_arg){
  394.             $init_args{$init_arg}++;
  395.         }
  396.     }
  397.  
  398.     while(my $key = each %{$args}){
  399.         if(!exists $init_args{$key}){
  400.             push @unknowns, $key;
  401.         }
  402.     }
  403.  
  404.     $metaclass->throw_error( sprintf
  405.         "Unknown attribute passed to the constructor of %s: %s",
  406.         $metaclass->name, Mouse::Util::english_list(@unknowns),
  407.     );
  408. }
  409.  
  410. package Mouse::Meta::Role;
  411.  
  412. sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' }
  413.  
  414. sub is_anon_role{
  415.     return exists $_[0]->{anon_serial_id};
  416. }
  417.  
  418. sub get_roles { $_[0]->{roles} }
  419.  
  420. sub add_before_method_modifier {
  421.     my ($self, $method_name, $method) = @_;
  422.  
  423.     push @{ $self->{before_method_modifiers}{$method_name} ||= [] }, $method;
  424.     return;
  425. }
  426. sub add_around_method_modifier {
  427.     my ($self, $method_name, $method) = @_;
  428.  
  429.     push @{ $self->{around_method_modifiers}{$method_name} ||= [] }, $method;
  430.     return;
  431. }
  432. sub add_after_method_modifier {
  433.     my ($self, $method_name, $method) = @_;
  434.  
  435.     push @{ $self->{after_method_modifiers}{$method_name} ||= [] }, $method;
  436.     return;
  437. }
  438.  
  439. sub get_before_method_modifiers {
  440.     my ($self, $method_name) = @_;
  441.     return @{ $self->{before_method_modifiers}{$method_name} ||= [] }
  442. }
  443. sub get_around_method_modifiers {
  444.     my ($self, $method_name) = @_;
  445.     return @{ $self->{around_method_modifiers}{$method_name} ||= [] }
  446. }
  447. sub get_after_method_modifiers {
  448.     my ($self, $method_name) = @_;
  449.     return @{ $self->{after_method_modifiers}{$method_name} ||= [] }
  450. }
  451.  
  452. package Mouse::Meta::Attribute;
  453.  
  454. require Mouse::Meta::Method::Accessor;
  455.  
  456. sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Mouse::Meta::Method::Accessor' }
  457.  
  458. # readers
  459.  
  460. sub name                 { $_[0]->{name}                   }
  461. sub associated_class     { $_[0]->{associated_class}       }
  462.  
  463. sub accessor             { $_[0]->{accessor}               }
  464. sub reader               { $_[0]->{reader}                 }
  465. sub writer               { $_[0]->{writer}                 }
  466. sub predicate            { $_[0]->{predicate}              }
  467. sub clearer              { $_[0]->{clearer}                }
  468. sub handles              { $_[0]->{handles}                }
  469.  
  470. sub _is_metadata         { $_[0]->{is}                     }
  471. sub is_required          { $_[0]->{required}               }
  472. sub default              { $_[0]->{default}                }
  473. sub is_lazy              { $_[0]->{lazy}                   }
  474. sub is_lazy_build        { $_[0]->{lazy_build}             }
  475. sub is_weak_ref          { $_[0]->{weak_ref}               }
  476. sub init_arg             { $_[0]->{init_arg}               }
  477. sub type_constraint      { $_[0]->{type_constraint}        }
  478.  
  479. sub trigger              { $_[0]->{trigger}                }
  480. sub builder              { $_[0]->{builder}                }
  481. sub should_auto_deref    { $_[0]->{auto_deref}             }
  482. sub should_coerce        { $_[0]->{coerce}                 }
  483.  
  484. sub documentation        { $_[0]->{documentation}          }
  485. sub insertion_order      { $_[0]->{insertion_order}        }
  486.  
  487. # predicates
  488.  
  489. sub has_accessor         { exists $_[0]->{accessor}        }
  490. sub has_reader           { exists $_[0]->{reader}          }
  491. sub has_writer           { exists $_[0]->{writer}          }
  492. sub has_predicate        { exists $_[0]->{predicate}       }
  493. sub has_clearer          { exists $_[0]->{clearer}         }
  494. sub has_handles          { exists $_[0]->{handles}         }
  495.  
  496. sub has_default          { exists $_[0]->{default}         }
  497. sub has_type_constraint  { exists $_[0]->{type_constraint} }
  498. sub has_trigger          { exists $_[0]->{trigger}         }
  499. sub has_builder          { exists $_[0]->{builder}         }
  500.  
  501. sub has_documentation    { exists $_[0]->{documentation}   }
  502.  
  503. sub _process_options{
  504.     my($class, $name, $args) = @_;
  505.  
  506.     # taken from Class::MOP::Attribute::new
  507.  
  508.     defined($name)
  509.         or $class->throw_error('You must provide a name for the attribute');
  510.  
  511.     if(!exists $args->{init_arg}){
  512.         $args->{init_arg} = $name;
  513.     }
  514.  
  515.     # 'required' requires eigher 'init_arg', 'builder', or 'default'
  516.     my $can_be_required = defined( $args->{init_arg} );
  517.  
  518.     if(exists $args->{builder}){
  519.         # XXX:
  520.         # Moose refuses a CODE ref builder, but Mouse doesn't for backward compatibility
  521.         # This feature will be changed in a future. (gfx)
  522.         $class->throw_error('builder must be a defined scalar value which is a method name')
  523.             #if ref $args->{builder} || !defined $args->{builder};
  524.             if !defined $args->{builder};
  525.  
  526.         $can_be_required++;
  527.     }
  528.     elsif(exists $args->{default}){
  529.         if(ref $args->{default} && ref($args->{default}) ne 'CODE'){
  530.             $class->throw_error("References are not allowed as default values, you must "
  531.                               . "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])");
  532.         }
  533.         $can_be_required++;
  534.     }
  535.  
  536.     if( $args->{required} && !$can_be_required ) {
  537.         $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg");
  538.     }
  539.  
  540.     # taken from Mouse::Meta::Attribute->new and ->_process_args
  541.  
  542.     if(exists $args->{is}){
  543.         my $is = $args->{is};
  544.  
  545.         if($is eq 'ro'){
  546.             $args->{reader} ||= $name;
  547.         }
  548.         elsif($is eq 'rw'){
  549.             if(exists $args->{writer}){
  550.                 $args->{reader} ||= $name;
  551.              }
  552.              else{
  553.                 $args->{accessor} ||= $name;
  554.              }
  555.         }
  556.         elsif($is eq 'bare'){
  557.             # do nothing, but don't complain (later) about missing methods
  558.         }
  559.         else{
  560.             $is = 'undef' if !defined $is;
  561.             $class->throw_error("I do not understand this option (is => $is) on attribute ($name)");
  562.         }
  563.     }
  564.  
  565.     my $tc;
  566.     if(exists $args->{isa}){
  567.         $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa});
  568.     }
  569.  
  570.     if(exists $args->{does}){
  571.         if(defined $tc){ # both isa and does supplied
  572.             my $does_ok = do{
  573.                 local $@;
  574.                 eval{ "$tc"->does($args) };
  575.             };
  576.             if(!$does_ok){
  577.                 $class->throw_error("Cannot have both an isa option and a does option because '$tc' does not do '$args->{does}' on attribute ($name)");
  578.             }
  579.         }
  580.         else {
  581.             $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
  582.         }
  583.     }
  584.  
  585.     if($args->{coerce}){
  586.         defined($tc)
  587.             || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)");
  588.  
  589.         $args->{weak_ref}
  590.             && $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)");
  591.     }
  592.  
  593.     if ($args->{lazy_build}) {
  594.         exists($args->{default})
  595.             && $class->throw_error("You can not use lazy_build and default for the same attribute ($name)");
  596.  
  597.         $args->{lazy}      = 1;
  598.         $args->{builder} ||= "_build_${name}";
  599.         if ($name =~ /^_/) {
  600.             $args->{clearer}   ||= "_clear${name}";
  601.             $args->{predicate} ||= "_has${name}";
  602.         }
  603.         else {
  604.             $args->{clearer}   ||= "clear_${name}";
  605.             $args->{predicate} ||= "has_${name}";
  606.         }
  607.     }
  608.  
  609.     if ($args->{auto_deref}) {
  610.         defined($tc)
  611.             || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)");
  612.  
  613.         ( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') )
  614.             || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)");
  615.     }
  616.  
  617.     if (exists $args->{trigger}) {
  618.         ('CODE' eq ref $args->{trigger})
  619.             || $class->throw_error("Trigger must be a CODE ref on attribute ($name)");
  620.     }
  621.  
  622.     if ($args->{lazy}) {
  623.         (exists $args->{default} || defined $args->{builder})
  624.             || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it");
  625.     }
  626.  
  627.     return;
  628. }
  629.  
  630.  
  631. package Mouse::Meta::TypeConstraint;
  632.  
  633. sub name    { $_[0]->{name}    }
  634. sub parent  { $_[0]->{parent}  }
  635. sub message { $_[0]->{message} }
  636.  
  637. sub type_parameter           { $_[0]->{type_parameter} }
  638. sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
  639. sub _compiled_type_coercion  { $_[0]->{_compiled_type_coercion}  }
  640.  
  641. sub __is_parameterized { exists $_[0]->{type_parameter} }
  642. sub has_coercion {       exists $_[0]->{_compiled_type_coercion} }
  643.  
  644.  
  645. sub compile_type_constraint{
  646.     my($self) = @_;
  647.  
  648.     # add parents first
  649.     my @checks;
  650.     for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){
  651.          if($parent->{hand_optimized_type_constraint}){
  652.             unshift @checks, $parent->{hand_optimized_type_constraint};
  653.             last; # a hand optimized constraint must include all the parents
  654.         }
  655.         elsif($parent->{constraint}){
  656.             unshift @checks, $parent->{constraint};
  657.         }
  658.     }
  659.  
  660.     # then add child
  661.     if($self->{constraint}){
  662.         push @checks, $self->{constraint};
  663.     }
  664.  
  665.     if($self->{type_constraints}){ # Union
  666.         my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} };
  667.         push @checks, sub{
  668.             foreach my $c(@types){
  669.                 return 1 if $c->($_[0]);
  670.             }
  671.             return 0;
  672.         };
  673.     }
  674.  
  675.     if(@checks == 0){
  676.         $self->{compiled_type_constraint} = \&Mouse::Util::TypeConstraints::Any;
  677.     }
  678.     else{
  679.         $self->{compiled_type_constraint} =  sub{
  680.             my(@args) = @_;
  681.             local $_ = $args[0];
  682.             foreach my $c(@checks){
  683.                 return undef if !$c->(@args);
  684.             }
  685.             return 1;
  686.         };
  687.     }
  688.     return;
  689. }
  690.  
  691. sub check {
  692.     my $self = shift;
  693.     return $self->_compiled_type_constraint->(@_);
  694. }
  695.  
  696.  
  697. package Mouse::Object;
  698.  
  699. sub BUILDARGS {
  700.     my $class = shift;
  701.  
  702.     if (scalar @_ == 1) {
  703.         (ref($_[0]) eq 'HASH')
  704.             || $class->meta->throw_error("Single parameters to new() must be a HASH ref");
  705.  
  706.         return {%{$_[0]}};
  707.     }
  708.     else {
  709.         return {@_};
  710.     }
  711. }
  712.  
  713. sub new {
  714.     my $class = shift;
  715.  
  716.     $class->meta->throw_error('Cannot call new() on an instance') if ref $class;
  717.  
  718.     my $args = $class->BUILDARGS(@_);
  719.  
  720.     my $meta = Mouse::Meta::Class->initialize($class);
  721.     return $meta->new_object($args);
  722. }
  723.  
  724. sub DESTROY {
  725.     my $self = shift;
  726.  
  727.     return unless $self->can('DEMOLISH'); # short circuit
  728.  
  729.     local $?;
  730.  
  731.     my $e = do{
  732.         local $@;
  733.         eval{
  734.             # DEMOLISHALL
  735.  
  736.             # We cannot count on being able to retrieve a previously made
  737.             # metaclass, _or_ being able to make a new one during global
  738.             # destruction. However, we should still be able to use mro at
  739.             # that time (at least tests suggest so ;)
  740.  
  741.             foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) {
  742.                 my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH')
  743.                     || next;
  744.  
  745.                 $self->$demolish($Mouse::Util::in_global_destruction);
  746.             }
  747.         };
  748.         $@;
  749.     };
  750.  
  751.     no warnings 'misc';
  752.     die $e if $e; # rethrow
  753. }
  754.  
  755. sub BUILDALL {
  756.     my $self = shift;
  757.  
  758.     # short circuit
  759.     return unless $self->can('BUILD');
  760.  
  761.     for my $class (reverse $self->meta->linearized_isa) {
  762.         my $build = Mouse::Util::get_code_ref($class, 'BUILD')
  763.             || next;
  764.  
  765.         $self->$build(@_);
  766.     }
  767.     return;
  768. }
  769.  
  770. sub DEMOLISHALL;
  771. *DEMOLISHALL = \&DESTROY;
  772.  
  773. 1;
  774. __END__
  775.  
  776. =head1 NAME
  777.  
  778. Mouse::PurePerl - A Mouse guts in pure Perl
  779.  
  780. =head1 VERSION
  781.  
  782. This document describes Mouse version 0.64
  783.  
  784. =head1 SEE ALSO
  785.  
  786. L<Mouse::XS>
  787.  
  788. =cut
  789.